{- This file is part of funbot.
 -
 - Written in 2015, 2016, 2017 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For byte strings
{-# LANGUAGE OverloadedStrings #-}

module FunBot.IrcHandlers
    ( handleBotMsg
    , handleJoin
    , handlePart
    , handleQuit
    , handleMsg
    , handleAction
    , handlePersonalMsg
    , handlePersonalAction
    , handleNickChange
    , handleNames
    )
where

import Control.Arrow ((***))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Chan (writeChan)
import Control.Exception (catch)
import Control.Monad (liftM, unless, when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Char (isAlphaNum)
import Data.Foldable (for_)
import Data.Maybe (isJust, listToMaybe, mapMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Units
import Database.Esqueleto hiding (update, (=.), (==.))
import Database.Persist
import Network.HTTP.Client
import Network.IRC.Fun.Types.Base
import Text.HTML.TagSoup

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.UTF8 as BU
import qualified Database.Esqueleto as E
import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as S
import qualified Data.Text as T

import Network.IRC.Fun.Bot.Chat (sendToChannel)
import Network.IRC.Fun.Bot.State

import FunBot.Config (welcomeDelay)
import FunBot.ExtEvents
import FunBot.History (reportHistory)
import FunBot.Memos
import FunBot.Model
import FunBot.Types
import FunBot.UserOptions (getUserHistoryOpts)
import FunBot.Util (unsnoc, runDB)

waveWordsL :: [Text]
waveWordsL = ["\\o", "\\O", "\\0"]

waveWordsR :: [Text]
waveWordsR = ["o/", "O/", "0/"]

lastChars :: [Char]
lastChars = ".!?"

isWord :: [Text] -> Maybe [Char] -> Text -> Bool
isWord ws mcs w =
    case listToMaybe $ mapMaybe (flip T.stripPrefix $ T.toLower w) ws of
        Nothing -> False
        Just r  ->
            case T.uncons $ T.stripStart r of
                Nothing     -> True
                Just (c, _) -> maybe True (c `elem`) mcs

isHello :: Text -> Bool
isHello = isWord ["hello", "hi", "hey", "yo"] (Just lastChars)

isPing :: Text -> Bool
isPing = isWord ["ping"] (Just lastChars)

isThanks :: Text -> Bool
isThanks = isWord ["thanks", "thank you"] Nothing

sayHello :: Channel -> Nickname -> MsgContent -> BotSession ()
sayHello chan (Nickname nick) (MsgContent msg)
    | isHello msg           = sendToChannel chan $ MsgContent $ "Hello, " <> nick
    | isPing msg            = sendToChannel chan $ MsgContent $ nick <> ", pong"
    | isThanks msg          = sendToChannel chan $ MsgContent $ nick <> ", you’re welcome!"
    | msg `elem` waveWordsL = sendToChannel chan $ MsgContent $ nick <> ": o/"
    | msg `elem` waveWordsR = sendToChannel chan $ MsgContent $ nick <> ": \\o"
    | otherwise             = return ()

recordTime :: Channel -> BotSession ()
recordTime chan = do
    getTime <- askTimeGetter
    now <- liftIO $ fmap fst getTime
    let update = M.insert chan now
    modifyState $ \ s -> s { bsLastMsgTime = update $ bsLastMsgTime s }

handleBotMsg
    :: Channel
    -> Nickname
    -> MsgContent
    -> MsgContent
    -> BotSession ()
handleBotMsg chan nick msg _full = do
    sayHello chan nick msg
    dispatchChannelMemos nick chan
    recordTime chan

{-
isUnderscored :: Nickname -> Channel -> BotSession Bool
isUnderscored nick chan =
    case unsnoc $ unNickname nick of
        Just (t, '_') ->
            isJust <$> (runDB $ getBy $ UniqueKith chan $ Nickname t)
        _             -> return False
-}

handleJoin :: Channel -> Nickname -> BotSession ()
handleJoin chan nick = do
    sel <- channelSelected chan
    when sel $ void $ runDB $ insertUnique Kith
        { kithChannel  = chan
        , kithNickname = nick
        , kithSpoke    = False
        }
    reportMemos nick chan
    hd <- getUserHistoryOpts nick chan
    when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd) True

handlePart :: Channel -> Nickname -> Maybe Comment -> BotSession ()
handlePart chan nick _ = do
    let f = M.adjust (id *** S.delete chan) nick
    modifyState $ \ s -> s { bsMemoReady = f $ bsMemoReady s }

handleQuit :: Nickname -> Maybe Comment -> BotSession ()
handleQuit nick _ = do
    let f = M.delete nick
    modifyState $ \ s -> s { bsMemoReady = f $ bsMemoReady s }

goodHost :: B.ByteString -> Bool
goodHost h =
    let n = B.length h
        suffix6 = B.drop (n - 6) h
        suffix4 = B.drop 2 suffix6
        isCo = B.length suffix6 == 6 && ".co." `B.isPrefixOf` suffix6
        isCom = suffix4 == ".com"
    in  not $ isCom || isCo

findTitle :: String -> Maybe Text
findTitle page =
    let tags = parseTags page
        from = drop 1 $ dropWhile (not . isTagOpenName "title") tags
        range = takeWhile (not . isTagCloseName "title") from
        text = unwords $ words $ innerText range
    in  if null text then Nothing else Just $ T.pack text

findLinks :: LinkDetectionMode -> Text -> [Text]
findLinks LDMMessage   t = [t]
findLinks LDMFirstWord t =
    let ws = T.words t
    in  if null ws
            then []
            else [head ws]
findLinks LDMAllWords  t = T.words t

sayTitle :: Channel -> MsgContent -> BotSession ()
sayTitle chan (MsgContent msg) = do
    chans <- getStateS $ stChannels . bsSettings
    case maybe Nothing csSayTitles $ M.lookup chan chans of
        Nothing -> return ()
        Just ldm -> do
            manager <- askEnvS httpManager
            let action t = if "http" `T.isPrefixOf` t
                    then do
                        request <- parseUrl $ T.unpack t
                        let h = host request
                        if goodHost h
                            then do
                                response <- httpLbs request manager
                                let page = BU.toString $ responseBody response
                                return $ Right $ findTitle page
                            else return $ Right Nothing
                    else return $ Right Nothing
                handler e = return $ Left (e :: HttpException)
                getTitle t = action t `catch` handler
            for_ (findLinks ldm msg) $ \ t -> do
                etitle <- liftIO $ getTitle t
                case etitle of
                    Right (Just title) ->
                        sendToChannel chan $ MsgContent $ "“" <> title <> "”"
                    _                  -> return ()

-- | Search for a shortcut prefix in the string, and return the word following
-- it (i.e. the argument) if found. Requirements and conditions:
--
-- * The prefix must come after a non-alphanum char (or beginning of message)
-- * The argument is the longest alphanum sequence following the prefix
--
-- (1) see if we have the prefix here
-- (2) if yes, take until non-alphanum and DONE
-- (3) if not, check if the first char is alphanum
-- (4) if yes, drop it and then all alphanum and repeat
-- (5) if not, drop it and repeat
search
    :: Text -- ^ Search in this
    -> Text -- ^ Search for this
    -> Maybe Text
search msg pref =
    if T.null pref
        then Nothing
        else f msg
    where
    skip = isAlphaNum
    pick = isAlphaNum
    once t =
        case T.stripPrefix pref t of
            Just r  ->
                let a = T.takeWhile pick r
                in  if T.null a
                        then Nothing
                        else Just a
            Nothing -> Nothing
    f t =
        case once t of
            succ@(Just _) -> succ
            Nothing       ->
                case T.uncons t of
                    Nothing     -> Nothing
                    Just (c, r) ->
                        if skip c
                            then f $ T.dropWhile skip r
                            else f r

format' :: Shortcut -> Text -> Text
format' cut t = T.concat
    [ shortcutPrefix cut
    , t
    , " | "
    , shortcutBefore cut
    , t
    , shortcutAfter cut
    ]

sayTicket :: Channel -> MsgContent -> BotSession ()
sayTicket chan (MsgContent msg) = do
    cuts <- runDB $ select $ from $ \ (s `InnerJoin` c) -> do
        on $ s ^. ShortcutId E.==. c ^. ShortcutChannelShortcut
        where_ $ c ^. ShortcutChannelChannel E.==. val chan
        return s
    let getres cut = fmap (\ s -> (cut, s)) $ search msg (shortcutPrefix cut)
        results = mapMaybe (getres . entityVal) cuts
        first = listToMaybe results
    case first of
        Nothing       -> return ()
        Just (cut, s) -> sendToChannel chan $ MsgContent $ format' cut s

handleMsg :: Channel -> Nickname -> MsgContent -> Bool -> BotSession ()
handleMsg chan nick msg _mention = do
    sel <- channelSelected chan
    when sel $ runDB $ do
        mkith <- getBy $ UniqueKith chan nick
        for_ mkith $ \ (Entity kid k) ->
            unless (kithSpoke k) $ do
                chans <- lift $ getStateS $ stChannels . bsSettings
                case M.lookup chan chans of
                    Nothing -> return ()
                    Just cs -> when (csWelcome cs) $ do
                        q <- lift $ askEnvS loopbackQueue
                        liftIO $ void $ forkIO $ do
                            threadDelay $ welcomeDelay * 1000 * 1000
                            writeChan q $
                                WelcomeEvent (unNickname nick) (unChannel chan)
                update kid [KithSpoke =. True]
    sayTitle chan msg
    sayTicket chan msg
    dispatchChannelMemos nick chan
    recordTime chan

handleAction :: Channel -> Nickname -> MsgContent -> Bool -> BotSession ()
handleAction chan nick msg _mention = do
    sayTicket chan msg
    dispatchChannelMemos nick chan
    recordTime chan

handlePersonalMsg :: Nickname -> MsgContent -> BotSession ()
handlePersonalMsg nick _ = dispatchPrivateMemos nick

handlePersonalAction :: Nickname -> MsgContent -> BotSession ()
handlePersonalAction nick _ = dispatchPrivateMemos nick

handleNickChange :: Nickname -> Nickname -> BotSession ()
handleNickChange old new = reportAllMemos old new

handleNames
    :: Channel
    -> ChannelPrivacy
    -> [(Privilege, Nickname)]
    -> BotSession ()
handleNames chan _priv pairs = do
    sel <- channelSelected chan
    when sel $ runDB $ do
        kiths <- selectList [KithChannel ==. chan] []
        let nicks = map snd pairs
            nicksCurr = map (kithNickname . entityVal) kiths
            nicksIns = S.fromList nicks `S.difference` S.fromList nicksCurr
        insertMany_ $ map (\ n -> Kith chan n False) $ S.toList nicksIns
